home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / comm.swg / 0052_RIP Graphics.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-08-24  |  13.9 KB  |  369 lines
  1.  
  2. { RIPSEE.PAS version 1.0 views a RIP 1.54 in EGA
  3. Public domain by Jason Dyer, use is free, but it would be nice if you gave
  4. me credit. Netmail at jason.dyer@solitud.fidonet.org on Internet or 1:300/23
  5. on Fidonet. If anyone can tell me the REAL way to scroll the graphic part of
  6. the screen please tell me.
  7. This program assumes you have TP/BP 7.0+ because of the new fonts it adds.
  8. If you are using anything less you will have to add the new fonts manually.
  9. Also, the icon format is different...the "trash byte" isn't used in 6.0.
  10. A few things are missing, like mouse buttons and the text window...expect
  11. them in a later version. }
  12.  
  13. PROGRAM RipSee;
  14.  
  15. USES Crt, Dos, Graph;
  16.  
  17. CONST Place : ARRAY [1..5] OF LONGINT = (1, 36, 1296, 46656, 1679616);
  18.       Seq = ('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ');
  19.  
  20. VAR ErrorCode : INTEGER;
  21.   GrDriver, GrMode : INTEGER;
  22.   f : TEXT;
  23.   SSS : STRING;
  24.   ccol : INTEGER;
  25.   Ch : CHAR;
  26.   Clipboard : POINTER;
  27.   LLL : INTEGER;
  28.   command : STRING;
  29.   RipLine, bslash : BOOLEAN;
  30.  
  31. FUNCTION FileExists (zzz : STRING) : BOOLEAN;
  32. VAR DoCheck : SearchRec;
  33. BEGIN
  34.   FINDFIRST (zzz, AnyFile, DoCheck);
  35.   IF DosError = 0 THEN FileExists := TRUE ELSE FileExists := FALSE;
  36. END;
  37.  
  38. PROCEDURE WriteString (SSS : STRING; CP : INTEGER);
  39. VAR Prloop : INTEGER;
  40.     Regs : REGISTERS;
  41. BEGIN
  42.   regs.ah := $0E;
  43.   regs.bh := 0;
  44.   regs.bl := cp;
  45.   FOR PrLoop := 1 TO LENGTH (SSS) DO BEGIN
  46.     Regs.Al := ORD (SSS [PrLoop]);
  47.     INTR ($10, Regs);
  48.   END;
  49. END;
  50.  
  51. FUNCTION Convert (SS : STRING) : LONGINT;
  52. VAR PrLoop, Counter : INTEGER;
  53.     CA, Tag : LONGINT;
  54. BEGIN
  55.   IF LENGTH (ss) = 1 THEN ss := '0' + ss;
  56.   Counter := 0; CA := 0;
  57.   FOR PrLoop := LENGTH (SS) DOWNTO 1 DO BEGIN
  58.     Counter := Counter + 1;
  59.     Tag := POS (SS [PrLoop], Seq) - 1;
  60.     CA := CA + (Tag * Place [Counter]);
  61.   END;
  62.   Convert := CA;
  63. END;
  64.  
  65. PROCEDURE DrawBezierCurve (px1, py1, px2, py2, px3, py3, px4, py4, count : INTEGER);
  66. FUNCTION pow (x : REAL; y : WORD) : REAL;
  67. VAR
  68.   nt     : WORD;
  69.   result : REAL;
  70. BEGIN
  71.  result := 1;
  72.  FOR nt := 1 TO y DO
  73.      result := result * x;
  74.  pow := result;
  75. END;
  76.  
  77. PROCEDURE Bezier (t : REAL; VAR x, y : INTEGER);
  78. BEGIN
  79.  x := TRUNC (pow (1 - t, 3) * px1 + 3 * t * pow (1 - t, 2) * px2 +
  80.                 3 * t * t * (1 - t) * px3 + pow (t, 3) * px4);
  81.  y := TRUNC (pow (1 - t, 3) * py1 + 3 * t * pow (1 - t, 2) * py2 +
  82.                 3 * t * t * (1 - t) * py3 + pow (t, 3) * py4);
  83. END;
  84. VAR
  85.  resolution, t : REAL;
  86.  xc, yc       : INTEGER;
  87. BEGIN
  88.   IF count = 0 THEN EXIT;
  89.   resolution := 1 / count;
  90.   MOVETO (px1, py1);
  91.   t := 0;
  92.   WHILE t < 1 DO BEGIN
  93.     Bezier (t, xc, yc);
  94.     LINETO (xc, yc);
  95.     t := t + resolution;
  96.   END;
  97.   LINETO (px4, py4);
  98. END;
  99.  
  100. PROCEDURE Scrollgraph (x1, y1, x2, y2, dest : INTEGER);
  101. VAR PP : POINTER;
  102. BEGIN
  103.   IF x1 MOD 8 <> 0 THEN x1 := x1 DIV 8;
  104.   IF x2 MOD 8 <> 0 THEN x2 := (x2 + 8) DIV 8;
  105.   GETMEM (pp, IMAGESIZE (x1, y1, x2, y2) );
  106.   GETIMAGE (x1, y1, x2, y2, pp^);
  107.   PUTIMAGE (x1, dest, pp^, 0);
  108.   DISPOSE (pp);
  109. END;
  110.  
  111. PROCEDURE ResetWindows;
  112. BEGIN
  113.   SETVIEWPORT (0, 0, GETMAXX, GETMAXY, ClipOn);
  114.   CLEARDEVICE; IF clipboard <> NIL THEN DISPOSE (clipboard);
  115.   clipboard := NIL;
  116. END;
  117.  
  118. PROCEDURE usersetf;
  119. VAR ii, jj : INTEGER;
  120.     zz : FillPatternType;
  121. BEGIN
  122.   jj := 0;
  123.   FOR ii := 1 TO 8 DO BEGIN
  124.     jj := jj + 2;
  125.     zz [ii] := Convert (COPY (command, jj, 2) );
  126.   END;
  127.   SETFILLPATTERN (zz, Convert (COPY (command, 18, 2) ) );
  128. END;
  129.  
  130. PROCEDURE DPoly (fillit, ifpoly : BOOLEAN; np : INTEGER);
  131. VAR ii, zz, yy : INTEGER;
  132.     poly : ARRAY [1..200] OF PointType;
  133. BEGIN
  134.   ii := 4;
  135.   FOR zz := 1 TO np DO BEGIN
  136.     poly [zz].x := Convert (COPY (command, ii, 2) );
  137.     poly [zz].y := Convert (COPY (command, ii + 2, 2) );
  138.     ii := ii + 4;
  139.   END; IF ifpoly THEN BEGIN
  140.     poly [np + 1] := poly [1];
  141.     IF NOT fillit THEN DRAWPOLY (np + 1, poly) ELSE FILLPOLY (np + 1, poly);
  142.   END ELSE IF NOT fillit THEN DRAWPOLY (np, poly) ELSE FILLPOLY (np, poly);
  143. END;
  144.  
  145. PROCEDURE toclip (x1, y1, x2, y2 : INTEGER);
  146. BEGIN
  147.   IF clipboard <> NIL THEN DISPOSE (clipboard);
  148.   GETMEM (clipboard, IMAGESIZE (x1, y1, x2, y2) );
  149.   GETIMAGE (x1, y1, x2, y2, ClipBoard^);
  150. END;
  151.  
  152. PROCEDURE LoadIcon (x, y, mode, cboard : INTEGER; fname : STRING);
  153. VAR fi : FILE;
  154.     P : POINTER;
  155.     Z : LONGINT;
  156.     tt : TextSettingsType;
  157.     cc : WORD;
  158. BEGIN
  159.   IF NOT fileexists (fname) THEN BEGIN
  160.     IF cboard = 1 THEN clipboard := NIL;
  161.     GETTEXTSETTINGS (tt); cc := GETCOLOR;
  162.     SETTEXTSTYLE (DefaultFont, HorizDir, 1); SETCOLOR (15);
  163.     OUTTEXTXY (x, y, Fname);
  164.     OUTTEXTXY (x, y + TEXTHEIGHT (Fname), 'not found');
  165.     SETCOLOR (cc); SETTEXTSTYLE (tt.font, tt.direction, tt.charsize);
  166.   END ELSE BEGIN
  167.     ASSIGN (fi, fname); NEW (P);
  168.     RESET (fi);
  169.     z := FILESIZE (fi);
  170.     GETMEM (P, FILESIZE (fi) );
  171.     BLOCKREAD (fi, P^, FILESIZE (fi) );
  172.     CLOSE (fi);
  173.     IF cboard = 1 THEN clipboard := p;
  174.     PUTIMAGE (x, y, p^, mode);
  175.     DISPOSE (p);
  176.   END;
  177. END;
  178.  
  179. PROCEDURE allpalette;
  180. VAR Pal : PaletteType;
  181.     ii, jj : INTEGER;
  182. BEGIN
  183.   Pal.Size := 16;
  184.   jj := 0;
  185.   FOR ii := 1 TO 16 DO BEGIN
  186.     jj := jj + 2;
  187.     Pal.Colors [ii - 1] := Convert (COPY (command, jj, 2) );
  188.   END;
  189.   SETALLPALETTE (Pal);
  190. END;
  191.  
  192. PROCEDURE ParseCommand (command : STRING);
  193. BEGIN
  194.   IF command = '*' THEN resetwindows;
  195.   IF command [1] = 'W' THEN SetWriteMode (Convert (COPY (command, 2, 2) ) );
  196.   IF command [1] = 'S' THEN SETFILLSTYLE (Convert (COPY (command, 2, 2) ),
  197.                                       Convert (COPY (command, 4, 2) ) );
  198.   IF command [1] = 'E' THEN CLEARVIEWPORT;
  199.   IF command [1] = 'v' THEN SETVIEWPORT (Convert (COPY (command, 2, 2) ),
  200.                           Convert (COPY (command, 4, 2) ),
  201.                           Convert (COPY (command, 6, 2) ),
  202.                           Convert (COPY (command, 8, 2) ), ClipOn);
  203.   IF command [1] = 'c' THEN IF LENGTH (command) = 2 THEN
  204.     BEGIN ccol := (POS (command [2], Seq) - 1); SETCOLOR (ccol); END
  205.     ELSE BEGIN ccol := (Convert (COPY (command, 2, 2) ) ); SETCOLOR (ccol); END;
  206.   IF command [1] = 'Y' THEN SETTEXTSTYLE (Convert (COPY (command, 2, 2) ),
  207.                                       Convert (COPY (command, 4, 2) ),
  208.                                       Convert (COPY (command, 6, 2) ) );
  209.   IF command [1] = 's' THEN usersetf;
  210.   IF command [1] = 'Q' THEN allpalette;
  211.   IF command [1] = '@' THEN OUTTEXTXY (Convert (COPY (command, 2, 2) ),
  212.                                    Convert (COPY (command, 4, 2) ),
  213.                                    COPY (command, 6, LENGTH (command) - 5) );
  214.   IF command [1] = 'F' THEN FLOODFILL (Convert (COPY (command, 2, 2) ),
  215.                           Convert (COPY (command, 4, 2) ),
  216.                           Convert (COPY (command, 6, 2) ) );
  217.   IF command [1] = 'C' THEN CIRCLE (Convert (COPY (command, 2, 2) ),
  218.                           Convert (COPY (command, 4, 2) ),
  219.                           Convert (COPY (command, 6, 2) ) );
  220.   IF command [1] = 'B' THEN BAR (Convert (COPY (command, 2, 2) ),
  221.                           Convert (COPY (command, 4, 2) ),
  222.                           Convert (COPY (command, 6, 2) ),
  223.                           Convert (COPY (command, 8, 2) ) );
  224.   IF command [1] = 'A' THEN ARC (Convert (COPY (command, 2, 2) ),
  225.                           Convert (COPY (command, 4, 2) ),
  226.                           Convert (COPY (command, 6, 2) ),
  227.                           Convert (COPY (command, 8, 2) ),
  228.                           Convert (COPY (command, 10, 2) ) );
  229.   IF command [1] = 'I' THEN PIESLICE (Convert (COPY (command, 2, 2) ),
  230.                           Convert (COPY (command, 4, 2) ),
  231.                           Convert (COPY (command, 6, 2) ),
  232.                           Convert (COPY (command, 8, 2) ),
  233.                           Convert (COPY (command, 10, 2) ) );
  234.   IF command [1] = 'i' THEN Sector (Convert (COPY (command, 2, 2) ),
  235.                           Convert (COPY (command, 4, 2) ),
  236.                           Convert (COPY (command, 6, 2) ),
  237.                           Convert (COPY (command, 8, 2) ),
  238.                           Convert (COPY (command, 10, 2) ),
  239.                           Convert (COPY (command, 12, 2) ) );
  240.   IF command [1] = 'L' THEN LINE (Convert (COPY (command, 2, 2) ),
  241.                           Convert (COPY (command, 4, 2) ),
  242.                           Convert (COPY (command, 6, 2) ),
  243.                           Convert (COPY (command, 8, 2) ) );
  244.   IF command [1] = 'R' THEN RECTANGLE (Convert (COPY (command, 2, 2) ),
  245.                           Convert (COPY (command, 4, 2) ),
  246.                           Convert (COPY (command, 6, 2) ),
  247.                           Convert (COPY (command, 8, 2) ) );
  248.   IF command [1] = 'o' THEN FillEllipse (Convert (COPY (command, 2, 2) ),
  249.                           Convert (COPY (command, 4, 2) ),
  250.                           Convert (COPY (command, 6, 2) ),
  251.                           Convert (COPY (command, 8, 2) ) );
  252.   IF (command [1] = 'O') OR (command [1] = 'V') THEN
  253.                           ELLIPSE (Convert (COPY (command, 2, 2) ),
  254.                           Convert (COPY (command, 4, 2) ),
  255.                           Convert (COPY (command, 6, 2) ),
  256.                           Convert (COPY (command, 8, 2) ),
  257.                           Convert (COPY (command, 10, 2) ),
  258.                           Convert (COPY (command, 12, 2) ) );
  259.   IF command [1] = 'P' THEN Dpoly (FALSE, TRUE, Convert (COPY (command, 2, 2) ) );
  260.   IF command [1] = 'p' THEN Dpoly (TRUE, TRUE, Convert (COPY (command, 2, 2) ) );
  261.   IF command [1] = 'X' THEN PUTPIXEL (Convert (COPY (command, 2, 2) ),
  262.                                   Convert (COPY (command, 4, 2) ), ccol);
  263.   IF command [1] = 'a' THEN SETPALETTE (Convert (COPY (command, 2, 2) ),
  264.                                     Convert (COPY (command, 4, 2) ) );
  265.   IF command [1] = '=' THEN SETLINESTYLE (Convert (COPY (command, 2, 2) ),
  266.                                       Convert (COPY (command, 4, 4) ),
  267.                                       Convert (COPY (command, 8, 2) ) );
  268.   IF command [1] = 'l' THEN Dpoly (FALSE, FALSE, Convert (COPY (command, 2, 2) ) );
  269.   IF command [1] = 'Z' THEN DrawBezierCurve (Convert (COPY (command, 2, 2) ),
  270.                           Convert (COPY (command, 4, 2) ),
  271.                           Convert (COPY (command, 6, 2) ),
  272.                           Convert (COPY (command, 8, 2) ),
  273.                           Convert (COPY (command, 10, 2) ),
  274.                           Convert (COPY (command, 12, 2) ),
  275.                           Convert (COPY (command, 14, 2) ),
  276.                           Convert (COPY (command, 16, 2) ),
  277.                           Convert (COPY (command, 18, 2) ) );
  278.   IF command [1] = '1' THEN BEGIN {level one commands}
  279.     IF command [2] = 'C' THEN Toclip (Convert (COPY (command, 3, 2) ),
  280.                                   Convert (COPY (command, 5, 2) ),
  281.                                   Convert (COPY (command, 7, 2) ),
  282.                                   Convert (COPY (command, 9, 2) ) );
  283.     IF (command [2] = 'P') AND (Clipboard <> NIL)
  284.                                THEN PUTIMAGE (Convert (COPY (command, 3, 2) ),
  285.                                     Convert (COPY (command, 5, 2) ),
  286.                                     Clipboard^,
  287.                                     Convert (COPY (command, 7, 2) ) );
  288.     IF command [2] = 'I' THEN LoadIcon (Convert (COPY (command, 3, 2) ),
  289.                                     Convert (COPY (command, 5, 2) ),
  290.                                     Convert (COPY (command, 7, 2) ),
  291.                                     Convert (COPY (command, 9, 1) ),
  292.                                     COPY (command, 12, LENGTH (command) - 11) );
  293.     IF command [2] = 'G' THEN Scrollgraph (Convert (COPY (command, 3, 2) ),
  294.                                        Convert (COPY (command, 5, 2) ),
  295.                                        Convert (COPY (command, 7, 2) ),
  296.                                        Convert (COPY (command, 9, 2) ),
  297.                                        Convert (COPY (command, 13, 2) ) );
  298.   END;
  299. END;
  300.  
  301. PROCEDURE Init;
  302. VAR FName : STRING;
  303. BEGIN
  304.   clipboard := NIL;
  305.   DETECTGRAPH (GrDriver, Grmode);
  306.   IF GrDriver < 3 THEN BEGIN
  307.     WRITELN ('EGA not detected!');
  308.     HALT (1);
  309.   END; GrMode := vgahi; Grdriver := vga;
  310.   INITGRAPH (GrDriver, GrMode, '\turbo\tp');  { The address of your BGI files }
  311.   ErrorCode := GRAPHRESULT;
  312.   IF ErrorCode <> grOK THEN
  313.   BEGIN
  314.     WRITELN ('Graphics error:');
  315.     WRITELN (GraphErrorMsg (ErrorCode) );
  316.     WRITELN ('Program aborted...');
  317.     HALT (1);
  318.   END;
  319.   Fname := PARAMSTR (1);
  320.   IF POS ('.', Fname) = 0 THEN Fname := Fname + '.RIP';
  321.   IF (NOT FileExists (Fname) ) OR (Fname = '.RIP') THEN BEGIN
  322.     WRITELN ('File not found!');
  323.     HALT (1);
  324.   END;
  325.   CLEARDEVICE; LLL := 0; command := ''; bslash := FALSE;
  326.   ASSIGN (f, Fname); ripline := FALSE; RESET (f);
  327. END;
  328.  
  329. BEGIN
  330.   Init;
  331.   REPEAT
  332.     READ (f, Ch);
  333.     IF (ORD (ch) = 13) OR (ORD (ch) = 10) THEN BEGIN
  334.       IF bslash = TRUE THEN BEGIN READ (f, ch); bslash := FALSE;
  335.       END ELSE BEGIN
  336.         LLL := 0; READ (f, ch);
  337.         IF ripline = TRUE THEN ripline := FALSE ELSE
  338.           WriteString (ch, 15);
  339.       END;
  340.     END ELSE BEGIN
  341.       LLL := LLL + 1;
  342.       IF (LLL = 1) AND (Ch = '!') THEN ripline := TRUE ELSE BEGIN
  343.         IF ripline THEN BEGIN
  344.           CASE ch OF
  345.           '|' : BEGIN
  346.             IF bslash THEN BEGIN command := command + ch; bslash := FALSE; END ELSE
  347.               BEGIN
  348.                 IF command <> '' THEN ParseCommand (command);
  349.                 command := '';
  350.               END;
  351.           END;
  352.           '\' : BEGIN
  353.             IF bslash THEN BEGIN command := command + ch; bslash := FALSE; END ELSE
  354.               bslash := TRUE;
  355.           END;
  356.           ELSE command := command + ch;
  357.           END;
  358.         END ELSE BEGIN
  359.           WriteString (ch, 15);
  360.         END;
  361.       END;
  362.     END;
  363.   UNTIL EOF (f);
  364.   CLOSE (f);
  365.   IF command <> '' THEN ParseCommand (command);
  366.   Ch := READKEY;
  367.   CLOSEGRAPH;
  368. END.
  369.